module Data.Fits.RecordParser where

import Text.ParserCombinators.Parsec
import Control.Monad.Error
import Data.Char
import Data.Fits.KeywordRecord

comment = ['C', 'O', 'M', 'M', 'E', 'N', 'T']
history = ['H', 'I', 'S', 'T', 'O', 'R', 'Y']
keyword_char = upper <|> digit <|> char '-' <|> char '_'
ascii_text_char = oneOf [' '..'~']
character_sign = oneOf "+-"
ascii_text_char_not_quote = oneOf $ [' '..'&'] ++ ['('..'~']
anychar_but_equal = oneOf $ [' '..'<'] ++ ['>'..'~']
anychar_but_space = oneOf ['!'..'~']
end_keyword = string "END" >> count 5 space

runP p s = case (parse p "" s) of
             (Left e)  -> throwError $ strMsg $ show e
             (Right x) -> return x

parseRecord :: String -> Either String KeywordRecord
parseRecord = runP recordParser  

recordParser = do
    keyword <- keywordParser
    if keyword `elem` [comment,history,""] 
      then commentParser keyword
      else try ( do { lookAhead anychar_but_equal <|> lookAhead (char '=' >> anychar_but_space);
                      commentParser keyword } )
           <|> valueParser keyword

keywordParser = f 8 where
    f 0 = return []
    f n = try g <|> do { count n space; return [] } where
        g = do
            a <- keyword_char
            b <- f (n-1)
            return (a:b)

commentParser keyword = do
    text <- many ascii_text_char
    eof
    let g | keyword == comment = CommentKeyword text
          | keyword == history = HistoryKeyword text
          | keyword == ""      = BLANKFIELDKeyword text
          | otherwise          = OtherKeyword keyword text
    return (CommentaryRecord g)

valueParser keyword = do
    char '='
    space
    skipMany space
    v <- option Undefined value
    skipMany space
    c <- option "" $ do { char '/';
                          t <- many ascii_text_char;
                          return t }
    eof
    return $ ValueRecord keyword v c

value = try character_string_value <|> try logical_value <|> try floating_value <|> try integer_value <|> 
                                                             try complex_floating_value <|> complex_integer_value

mkValueParser p = p >>= return . toValue
character_string_value = mkValueParser character_string_value_Parser
logical_value          = mkValueParser logical_value_Parser
integer_value          = mkValueParser integer_value_Parser
floating_value         = mkValueParser floating_value_Parser 
complex_floating_value = mkValueParser complex_floating_value_Parser
complex_integer_value  = mkValueParser complex_integer_value_Parser

character_string_value_Parser = do
    char '\''
    text <- f
    char '\'' 
    return text
  where 
    f = try g <|> return "" 
    g = do
        a <- ascii_text_char_not_quote <|> ( do { string "''"; 
                                                  return '\'' } )
        b <- f
        return (a:b)    

logical_value_Parser = do
    v <- oneOf ['T', 'F']
    let g | v == 'T'  = True
          | otherwise = False
    return g 


integer_value_Parser = do
    s <- option '+' character_sign
    d <- many1 digit
    let numeric = foldl (\a b -> 10*a + b) 0 $ map (toInteger . digitToInt) d
    return $ sign s $ numeric 

sign s | s == '-' = negate
       | s == '+' = id
       | otherwise = error "Incorrect sign"
      

floating_value_Parser = do
    s <- option '+' character_sign
    (i, f) <- try ( do { i <- many1 digit;
                         char '.';
                         f <- many1 digit;
                         return (i, f) } )
              <|> try ( do { i <- many1 digit;
                             try (char '.') <|> lookAhead (oneOf ['E', 'D']);
                             return (i, []) } )
              <|> do { char '.';
                       f <- many1 digit;
                       return ([], f) }

    exp <- option 0.0 $ do { oneOf ['E', 'D'];
                             i <- integer_value_Parser;
                             return $ fromInteger i }

    let digitsToNum = map (fromInteger . toInteger . digitToInt)
    let integral_part = foldl (\a b -> 10.0*a + b) 0.0 $ digitsToNum i
    let fractional_part = foldr (\a b -> a + 0.1*b) 0.0 $ digitsToNum ('0':f)
    let x = sign s $ (integral_part + fractional_part) * 10.0**exp 
    return (x :: Double)

tuple_Parser t = do
    char '('
    skipMany space
    a <- t
    skipMany space
    char ','
    skipMany space
    b <- t
    skipMany space
    char ')'
    return (a,b)

complex_floating_value_Parser = tuple_Parser floating_value_Parser
complex_integer_value_Parser  = tuple_Parser integer_value_Parser
